(*
     The contents of this file are subject to the Mozilla Public License
     Version 1.1 (the "License"); you may not use this file except in
     compliance with the License. You may obtain a copy of the License at
     http://www.mozilla.org/MPL/

     Software distributed under the License is distributed on an "AS IS"
     basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
     License for the specific language governing rights and limitations
     under the License.

     The Original Code is CrossFPC.

     The Initial Developer of the Original Code is Simon Kissel.
     Portions created by Benjamin Rosseaux are Copyright (C) Benjamin Rosseaux.
     All Rights Reserved.

*)

unit cfbesenobjects;
{$WARNINGS off}

interface

uses
  Windows, SysUtils, Classes, BESEN, BESENValue, BESENTypes, BESENConstants,
  BESENNativeObject, BESENObject, BESENUtils, BESENErrors, BESENStringUtils,
  BESENCharset, BESENNumberUtils, BESENDateUtils, BESENVersionConstants,
  BeRoBufferedStream, BeRoMappedStream;

type
  TBESENObjectFile = class(TBESENNativeObject)
  private
    fFileName: TBESENString;
    fFileStream: TBeRoBufferedStream;
    fFileHandle: THandle;
  protected
    procedure ConstructObject(const ThisArgument: TBESENValue; Arguments:
      PPBESENValues; CountArguments: integer); override;
    procedure InitializeObject; override;
    procedure FinalizeObject; override;
  public
    constructor Create(AInstance: TObject; APrototype: TBESENObject = nil;
      AHasPrototypeProperty: longbool = false); override;
    destructor Destroy; override;
  published
    procedure close(const ThisArgument: TBESENValue; Arguments: PPBESENValues;
      CountArguments: integer; var ResultValue: TBESENValue);
    procedure read(const ThisArgument: TBESENValue; Arguments: PPBESENValues;
      CountArguments: integer; var ResultValue: TBESENValue);
    procedure write(const ThisArgument: TBESENValue; Arguments: PPBESENValues;
      CountArguments: integer; var ResultValue: TBESENValue);
    procedure seek(const ThisArgument: TBESENValue; Arguments: PPBESENValues;
      CountArguments: integer; var ResultValue: TBESENValue);
    procedure position(const ThisArgument: TBESENValue; Arguments:
      PPBESENValues; CountArguments: integer; var ResultValue: TBESENValue);
    procedure eof(const ThisArgument: TBESENValue; Arguments: PPBESENValues;
      CountArguments: integer; var ResultValue: TBESENValue);
    procedure flush(const ThisArgument: TBESENValue; Arguments: PPBESENValues;
      CountArguments: integer; var ResultValue: TBESENValue);
    property fileName: TBESENString read fFileName write fFileName;
  end;

  TBESENObjectUtils = class(TBESENNativeObject)
  published
    procedure alert(const ThisArgument: TBESENValue; Arguments: PPBESENValues;
      CountArguments: integer; var ResultValue: TBESENValue);
    procedure execute(const ThisArgument: TBESENValue; Arguments: PPBESENValues;
      CountArguments: integer; var ResultValue: TBESENValue);
    procedure readFile(const ThisArgument: TBESENValue; Arguments:
      PPBESENValues; CountArguments: integer; var ResultValue: TBESENValue);
    procedure writeFile(const ThisArgument: TBESENValue; Arguments:
      PPBESENValues; CountArguments: integer; var ResultValue: TBESENValue);
    procedure readDirectory(const ThisArgument: TBESENValue; Arguments:
      PPBESENValues; CountArguments: integer; var ResultValue: TBESENValue);
    procedure load(const ThisArgument: TBESENValue; Arguments: PPBESENValues;
      CountArguments: integer; var ResultValue: TBESENValue);
    procedure GC(const ThisArgument: TBESENValue; Arguments: PPBESENValues;
      CountArguments: integer; var ResultValue: TBESENValue);
    procedure version(const ThisArgument: TBESENValue; Arguments: PPBESENValues;
      CountArguments: integer; var ResultValue: TBESENValue);
  end;

function DoExecute(const FileName, Parameter: widestring; WindowState:
  longword): longint;

implementation

function DoExecute(const FileName, Parameter: widestring; WindowState:
  longword): longint;
var
  SUInfo:
    {$IFDEF VER180}TStartupInfoW{$ELSE}{$IFDEF VER185}TStartupInfoW{$ELSE}TStartupInfo{$ENDIF}{$ENDIF};
  ProcInfo: TProcessInformation;
  CommandLine, CurrentDirectory: widestring;
  ExitCode: longword;
begin
  result := -1;
  if length(FileName) > 0 then
  begin
    CommandLine := '"' + FileName + '" ' + Parameter;
  end
  else
  begin
    CommandLine := '"cmd" /C ' + Parameter;
  end;
  FillChar(SUInfo, SizeOf(SUInfo), #0);
  FillChar(ProcInfo, SizeOf(ProcInfo), #0);
  SUInfo.CB := SIZEOF(SUInfo);
  SUInfo.dwFlags := STARTF_USESHOWWINDOW;
  SUInfo.wShowWindow := WindowState;
  CurrentDirectory := GetCurrentDir;
  if CreateProcessW(nil, pwidechar(CommandLine), nil, nil, false,
    NORMAL_PRIORITY_CLASS, nil, pwidechar(CurrentDirectory), SUInfo, ProcInfo)
    then
  begin
    WaitForSingleObject(ProcInfo.hProcess, INFINITE);
    if GetExitCodeProcess(ProcInfo.hProcess, ExitCode) then
    begin
      result := ExitCode;
    end;
    CloseHandle(ProcInfo.hProcess);
  end;
end;

constructor TBESENObjectFile.Create(AInstance: TObject; APrototype: TBESENObject
  = nil; AHasPrototypeProperty: longbool = false);
begin
  inherited Create(AInstance, APrototype, AHasPrototypeProperty);
  fFileStream := nil;
end;

destructor TBESENObjectFile.Destroy;
begin
  BesenFreeAndNil(fFileStream);
  inherited Destroy;
end;

procedure TBESENObjectFile.ConstructObject(const ThisArgument: TBESENValue;
  Arguments: PPBESENValues; CountArguments: integer);
var
  s: string;
  Mode: longword;
  fs: TFileStream;
begin
  inherited ConstructObject(ThisArgument, Arguments, CountArguments);
  if CountArguments = 0 then
  begin
    raise EBESENError.Create('FileError', 'Too few arguments');
  end
  else
  begin
    fFileName := TBESEN(Instance).ToStr(Arguments^[0]^);
    if FileExists(fFileName) then
    begin
      Mode := fmOpenReadWrite or fmShareExclusive;
    end
    else
    begin
      Mode := fmCreate or fmShareDenyRead;
    end;
    if CountArguments > 1 then
    begin
      s := TBESEN(Instance).ToStr(Arguments^[1]^);
      if s = 'c' then
      begin
        Mode := fmCreate or fmShareDenyRead;
      end
      else if s = 'r' then
      begin
        Mode := fmOpenRead or fmShareDenyWrite;
      end
      else if s = 'rw' then
      begin
        Mode := fmOpenReadWrite or fmShareExclusive;
      end
      else if s = 'w' then
      begin
        if FileExists(fFileName) then
        begin
          Mode := fmOpenWrite or fmShareDenyRead;
        end
        else
        begin
          Mode := fmCreate or fmShareDenyRead;
        end;
      end;
    end;
    try
      fs := TFileStream.Create(BESENEncodeString(BESENUTF16ToUTF8(fFileName),
        UTF_8, BESENLocaleCharset), Mode);
      fFileHandle := fs.Handle;
      fFileStream := TBeRoBufferedStream.Create(fs, true);
    except
      fFileStream := nil;
    end;
  end;
  s := '';
end;

procedure TBESENObjectFile.InitializeObject;
begin
  inherited InitializeObject;
  fFileName := '';
  fFileStream := nil;
end;

procedure TBESENObjectFile.FinalizeObject;
begin
  BesenFreeAndNil(fFileStream);
  inherited FinalizeObject;
end;

procedure TBESENObjectFile.close(const ThisArgument: TBESENValue; Arguments:
  PPBESENValues; CountArguments: integer; var ResultValue: TBESENValue);
begin
  ResultValue.ValueType := bvtUNDEFINED;
  BesenFreeAndNil(fFileStream);
end;

procedure TBESENObjectFile.read(const ThisArgument: TBESENValue; Arguments:
  PPBESENValues; CountArguments: integer; var ResultValue: TBESENValue);
var
  l, ms: int64;
  s: string;
begin
  s := '';
  ResultValue.ValueType := bvtUNDEFINED;
  if assigned(fFileStream) then
  begin
    ms := fFileStream.Size - fFileStream.Position;
    if CountArguments = 0 then
    begin
      l := ms;
    end
    else
    begin
      if Arguments^[0]^.ValueType = bvtUNDEFINED then
      begin
        l := ms;
      end
      else
      begin
        l := TBESEN(Instance).ToInt(Arguments^[0]^);
        if l > ms then
        begin
          l := ms;
        end;
      end;
    end;
    SetLength(s, l);
    if l > 0 then
    begin
      fFileStream.Read(s[1], l);
    end;
    ResultValue.ValueType := bvtSTRING;
    ResultValue.Str := s;
    SetLength(s, 0);
  end;
end;

procedure TBESENObjectFile.write(const ThisArgument: TBESENValue; Arguments:
  PPBESENValues; CountArguments: integer; var ResultValue: TBESENValue);
var
  l: int64;
  s: string;
begin
  s := '';
  ResultValue.ValueType := bvtUNDEFINED;
  if assigned(fFileStream) then
  begin
    if CountArguments > 0 then
    begin
      ResultValue.ValueType := bvtNUMBER;
      ResultValue.Num := 0;
      s := TBESEN(Instance).ToStr(Arguments^[0]^);
      l := length(s);
      if l > 0 then
      begin
        ResultValue.Num := fFileStream.Write(s[1], l);
      end;
      SetLength(s, 0);
    end;
  end;
end;

procedure TBESENObjectFile.seek(const ThisArgument: TBESENValue; Arguments:
  PPBESENValues; CountArguments: integer; var ResultValue: TBESENValue);
var
  l, ms: int64;
begin
  ResultValue.ValueType := bvtUNDEFINED;
  if assigned(fFileStream) then
  begin
    ms := fFileStream.Size;
    if CountArguments = 0 then
    begin
      l := fFileStream.Position;
    end
    else
    begin
      if Arguments^[0]^.ValueType = bvtUNDEFINED then
      begin
        l := fFileStream.Position;
      end
      else
      begin
        l := TBESEN(Instance).ToInt(Arguments^[0]^);
        if l > ms then
        begin
          l := ms;
        end;
      end;
    end;
    ResultValue.ValueType := bvtNUMBER;
    ResultValue.Num := fFileStream.Seek(l, soFromBeginning);
  end;
end;

procedure TBESENObjectFile.position(const ThisArgument: TBESENValue; Arguments:
  PPBESENValues; CountArguments: integer; var ResultValue: TBESENValue);
begin
  ResultValue.ValueType := bvtUNDEFINED;
  if assigned(fFileStream) then
  begin
    ResultValue.ValueType := bvtNUMBER;
    ResultValue.Num := fFileStream.Position;
  end;
end;

procedure TBESENObjectFile.eof(const ThisArgument: TBESENValue; Arguments:
  PPBESENValues; CountArguments: integer; var ResultValue: TBESENValue);
begin
  ResultValue.ValueType := bvtUNDEFINED;
  if assigned(fFileStream) then
  begin
    ResultValue.ValueType := bvtBOOLEAN;
    ResultValue.Bool := fFileStream.Position < fFileStream.Size;
  end;
end;

procedure TBESENObjectFile.flush(const ThisArgument: TBESENValue; Arguments:
  PPBESENValues; CountArguments: integer; var ResultValue: TBESENValue);
begin
  ResultValue.ValueType := bvtUNDEFINED;
  if assigned(fFileStream) then
  begin
    fFileStream.Flush;
  end;
end;

procedure TBESENObjectUtils.alert(const ThisArgument: TBESENValue; Arguments:
  PPBESENValues; CountArguments: integer; var ResultValue: TBESENValue);
var
  i: integer;
  v: PBESENValue;
  ss: widestring;
  procedure writeit(s: widestring);
  begin
    ss := ss + s;
  end;
begin
  ss := '';
  ResultValue.ValueType := bvtUNDEFINED;
  for i := 0 to CountArguments - 1 do
  begin
    v := Arguments^[i];
    case v^.ValueType of
      bvtUNDEFINED:
        begin
          writeit('undefined');
        end;
      bvtNULL:
        begin
          writeit('null');
        end;
      bvtBOOLEAN:
        begin
          if v^.Bool then
          begin
            writeit('true');
          end
          else
          begin
            writeit('false');
          end;
        end;
      bvtNUMBER:
        begin
          writeit(BESENFloatToStr(v^.Num));
        end;
      bvtSTRING:
        begin
          writeit(v^.Str);
        end;
      bvtOBJECT:
        begin
          writeit(TBESEN(Instance).ToStr(v^));
        end;
      bvtREFERENCE:
        begin
          writeit('reference');
        end;
    end;
  end;
  ResultValue.ValueType := bvtBOOLEAN;
  ResultValue.Bool := MessageBoxW(0, pwidechar(ss), 'CrossFPC', MB_OKCANCEL or
    MB_ICONINFORMATION) = ID_OK;
end;

procedure TBESENObjectUtils.execute(const ThisArgument: TBESENValue; Arguments:
  PPBESENValues; CountArguments: integer; var ResultValue: TBESENValue);
var
  FileName, Parameter: widestring;
  WindowState: longint;
begin
  ResultValue.ValueType := bvtUNDEFINED;
  if CountArguments > 0 then
  begin
    FileName := TBESEN(Instance).ToStr(Arguments^[0]^);
    if CountArguments > 1 then
    begin
      Parameter := TBESEN(Instance).ToStr(Arguments^[1]^);
    end
    else
    begin
      Parameter := '';
    end;
    if CountArguments > 2 then
    begin
      WindowState := TBESEN(Instance).ToInt32(Arguments^[2]^);
    end
    else
    begin
      WindowState := Windows.SW_SHOWNORMAL;
    end;
    ResultValue.ValueType := bvtNUMBER;
    ResultValue.Num := DoExecute(FileName, Parameter, WindowState);
  end;
end;

procedure TBESENObjectUtils.readFile(const ThisArgument: TBESENValue; Arguments:
  PPBESENValues; CountArguments: integer; var ResultValue: TBESENValue);
var
  FileName, Content: string;
  fm: byte;
  f: file;
begin
  ResultValue.ValueType := bvtUNDEFINED;
  try
    if CountArguments > 0 then
    begin
      FileName :=
        BESENEncodeString(BESENUTF16ToUTF8(TBESEN(Instance).ToStr(Arguments^[0]^)), UTF_8, BESENLocaleCharset);
      Content := '';
      fm := filemode;
      filemode := 0;
      assignfile(f, FileName);
{$I-}reset(f, 1);
{$I+};
      if ioresult = 0 then
      begin
        SetLength(Content, filesize(f));
        if length(Content) > 0 then
        begin
{$I-}blockread(f, Content[1], length(Content));
{$I+}
          if ioresult <> 0 then
          begin
{$I-}closefile(f);
{$I+}
            filemode := fm;
            raise EBESENError.Create('FileError', 'Couldn''t read file "' +
              FileName + '"');
            exit;
          end;
        end;
        ResultValue.ValueType := bvtSTRING;
        ResultValue.Str := BESENUTF8ToUTF16(BESENConvertToUTF8(Content));
{$I-}closefile(f);
{$I+}
        if ioresult = 0 then
        begin
        end;
        filemode := fm;
      end
      else
      begin
{$I-}closefile(f);
{$I+}
        if ioresult = 0 then
        begin
        end;
        filemode := fm;
        raise EBESENError.Create('FileError', 'Couldn''t read file "' + FileName
          + '"');
      end;
    end
    else
    begin
      raise EBESENError.Create('FileError', 'Too few arguments');
    end;
  finally
  end;
end;

procedure TBESENObjectUtils.writeFile(const ThisArgument: TBESENValue;
  Arguments: PPBESENValues; CountArguments: integer; var ResultValue:
  TBESENValue);
var
  FileName, Content: string;
  fm: byte;
  f: file;
begin
  ResultValue.ValueType := bvtUNDEFINED;
  try
    if CountArguments > 1 then
    begin
      FileName :=
        BESENEncodeString(BESENUTF16ToUTF8(TBESEN(Instance).ToStr(Arguments^[0]^)), UTF_8, BESENLocaleCharset);
      Content := #$EF#$BB#$BF +
        BESENUTF16ToUTF8(TBESEN(Instance).ToStr(Arguments^[1]^));
      fm := filemode;
      filemode := 2;
      assignfile(f, FileName);
{$I-}rewrite(f, 1);
{$I+};
      if ioresult = 0 then
      begin
        if length(Content) > 0 then
        begin
{$I-}blockwrite(f, Content[1], length(Content));
{$I+}
          if ioresult <> 0 then
          begin
{$I-}closefile(f);
{$I+}
            filemode := fm;
            raise EBESENError.Create('FileError', 'Couldn''t write file "' +
              FileName + '"');
            exit;
          end;
        end;
{$I-}closefile(f);
{$I+}
        if ioresult = 0 then
        begin
        end;
        filemode := fm;
      end
      else
      begin
{$I-}closefile(f);
{$I+}
        if ioresult = 0 then
        begin
        end;
        filemode := fm;
        raise EBESENError.Create('FileError', 'Couldn''t write file "' + FileName
          + '"');
      end;
    end
    else
    begin
      raise EBESENError.Create('FileError', 'Too few arguments');
    end;
  finally
  end;
end;

procedure TBESENObjectUtils.readDirectory(const ThisArgument: TBESENValue;
  Arguments: PPBESENValues; CountArguments: integer; var ResultValue:
  TBESENValue);
const
  BoolStr: array[boolean] of string = ('false', 'true');
var
  FileName, Content: string;
  SearchRec: TSearchRec;
  Count: integer;
begin
  ResultValue.ValueType := bvtUNDEFINED;
  try
    if CountArguments > 0 then
    begin
      Content := '[';
      FileName :=
        BESENEncodeString(BESENUTF16ToUTF8(TBESEN(Instance).ToStr(Arguments^[0]^)), UTF_8, BESENLocaleCharset);
      if FindFirst(FileName, faAnyFile or faDirectory, SearchRec) = 0 then
      begin
        Count := 0;
        repeat
          if Count > 0 then
          begin
            Content := Content + ',';
          end;
          Content := Content + '{';
          Content := Content + '"name":' +
            BESENJSONStringQuote(BESENUTF8ToUTF16(BESENEncodeString(SearchRec.Name, BESENLocaleCharset, UTF_8))) + ',';
          Content := Content + '"size":' + IntToStr(SearchRec.Size) + ',';
          Content := Content + '"time":' +
            BESENFloatToStr(BESENDateTimeToBESENDate(FileDateToDateTime(SearchRec.Time))) + ',';
          Content := Content + '"flags":{';
          Content := Content + '"hidden":' + BoolStr[(SearchRec.Attr and
            faHidden) <> 0] + ',';
          Content := Content + '"systemFile":' + BoolStr[(SearchRec.Attr and
            faSysFile) <> 0] + ',';
          Content := Content + '"volumeID":' + BoolStr[(SearchRec.Attr and
            faVolumeID) <> 0] + ',';
          Content := Content + '"directory":' + BoolStr[(SearchRec.Attr and
            faDirectory) <> 0] + ',';
          Content := Content + '"archive":' + BoolStr[(SearchRec.Attr and
            faArchive) <> 0] + '';
          Content := Content + '}}';
          inc(Count);
        until FindNext(SearchRec) <> 0;
        FindClose(SearchRec);
      end;
      Content := Content + ']';
      ResultValue := TBESEN(Instance).JSONEval(Content);
    end
    else
    begin
      raise EBESENError.Create('DirectoryError', 'Too few arguments');
    end;
  finally
  end;
end;

procedure TBESENObjectUtils.load(const ThisArgument: TBESENValue; Arguments:
  PPBESENValues; CountArguments: integer; var ResultValue: TBESENValue);
var
  FileName, Content: string;
  fm: byte;
  f: file;
begin
  ResultValue.ValueType := bvtUNDEFINED;
  try
    if CountArguments > 0 then
    begin
      FileName :=
        BESENEncodeString(BESENUTF16ToUTF8(TBESEN(Instance).ToStr(Arguments^[0]^)), UTF_8, BESENLocaleCharset);
      Content := '';
      fm := filemode;
      filemode := 0;
      assignfile(f, FileName);
{$I-}reset(f, 1);
{$I+};
      if ioresult = 0 then
      begin
        SetLength(Content, filesize(f));
        if length(Content) > 0 then
        begin
{$I-}blockread(f, Content[1], length(Content));
{$I+}
          if ioresult <> 0 then
          begin
{$I-}closefile(f);
{$I+}
            filemode := fm;
            raise EBESENError.Create('FileError', 'Couldn''t load file "' +
              FileName + '"');
            exit;
          end;
        end;
        ResultValue :=
          TBESEN(Instance).Execute(BESENUTF8ToUTF16(BESENConvertToUTF8(Content)));
{$I-}closefile(f);
{$I+}
        if ioresult = 0 then
        begin
        end;
        filemode := fm;
      end
      else
      begin
{$I-}closefile(f);
{$I+}
        if ioresult = 0 then
        begin
        end;
        filemode := fm;
        raise EBESENError.Create('FileError', 'Couldn''t load file "' + FileName
          + '"');
      end;
    end
    else
    begin
      raise EBESENError.Create('FileError', 'Too few arguments');
    end;
  finally
  end;
end;

procedure TBESENObjectUtils.GC(const ThisArgument: TBESENValue; Arguments:
  PPBESENValues; CountArguments: integer; var ResultValue: TBESENValue);
begin
  ResultValue.ValueType := bvtUNDEFINED;
  TBESEN(Instance).GarbageCollector.CollectAll;
end;

procedure TBESENObjectUtils.version(const ThisArgument: TBESENValue; Arguments:
  PPBESENValues; CountArguments: integer; var ResultValue: TBESENValue);
begin
  ResultValue.ValueType := bvtSTRING;
  ResultValue.Str := 'BESEN v' + BESENVersion +
    ' - Copyright (C) 2010-2011, Benjamin ''BeRo'' Rosseaux';
end;

end.

